home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 2 / Amiga Tools 2.iso / tools / jade / lisp / edit.jl < prev    next >
Lisp/Scheme  |  1995-03-09  |  15KB  |  514 lines
  1. ;;;; edit.jl -- High-level editing functions
  2. ;;;  Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (defvar word-regexp "[a-zA-Z0-9]"
  21.   "Regular expression which defines a character in a word.")
  22. (defvar word-not-regexp "[^a-zA-Z0-9]|$"
  23.   "Regular expression which defines anything that is not in a word.")
  24. (defvar paragraph-regexp "^[\t ]*$"
  25.   "Regular expression which matches a paragraph-separating piece of text.")
  26.  
  27. (make-variable-buffer-local 'word-regexp)
  28. (make-variable-buffer-local 'word-not-regexp)
  29. (make-variable-buffer-local 'paragraph-regexp)
  30.  
  31.  
  32. (defvar auto-mark (make-mark)
  33.   "Mark which some commands use to track the previous cursor position.")
  34.  
  35.  
  36. ;; Words
  37.  
  38. (defun forward-word (&optional number pos move)
  39.   "Return the position of first character after the end of this word.
  40. NUMBER is the number of words to move, negative values mean go backwards.
  41. If MOVE is t then the cursor is moved to the result."
  42.   (interactive "p\n\nt")
  43.   (unless number
  44.     (setq number 1))
  45.   (unless pos
  46.     (setq pos (cursor-pos)))
  47.   (cond
  48.     ((< number 0)
  49.       ;; go backwards
  50.       (while (/= number 0)
  51.     (setq pos (prev-char 1 pos))
  52.     (when (looking-at word-not-regexp pos)
  53.       ;; not in word
  54.       (unless (setq pos (find-prev-regexp word-regexp pos))
  55.         (error "Start of buffer")))
  56.     ;; in middle of word
  57.     (unless (setq pos (find-prev-regexp word-not-regexp pos))
  58.       (error "Start of buffer"))
  59.     (setq
  60.       pos (find-next-regexp word-regexp pos)
  61.       number (1+ number))))
  62.     (t
  63.       ;; forwards
  64.       (while (/= number 0)
  65.     (when (looking-at word-not-regexp pos)
  66.       ;; already at end of a word
  67.       (unless (setq pos (find-next-regexp word-regexp pos))
  68.         (error "End of buffer")))
  69.     (unless (setq pos (find-next-regexp word-not-regexp pos))
  70.       (error "End of buffer"))
  71.     (setq number (1- number)))))
  72.   (when move
  73.     (goto-char pos))
  74.   pos)
  75.  
  76. (defun backward-word (&optional number pos move)
  77.   "Basically `(forward-word -NUMBER POS MOVE)'"
  78.   (interactive "p\n\nt")
  79.   (forward-word (if number (- number) -1) pos move))
  80.  
  81. (defun kill-word (count)
  82.   "Kills from the cursor to the end of the word."
  83.   (interactive "p")
  84.   (kill-area (cursor-pos) (forward-word count)))
  85.  
  86. (defun backward-kill-word (count)
  87.   "Kills from the start of the word to the cursor."
  88.   (interactive "p")
  89.   (kill-area (forward-word (- count)) (cursor-pos)))
  90.  
  91. (defun word-start (&optional pos)
  92.   "Returns the position of the start of *this* word."
  93.   (when (looking-at word-regexp pos)
  94.     (unless (find-prev-regexp word-not-regexp pos)
  95.       (error "Start of buffer"))
  96.     (find-next-regexp word-regexp (match-end))))
  97.  
  98. (defun in-word-p (&optional pos)
  99.   "Returns t if POS is inside a word."
  100.   (when (looking-at word-regexp pos)
  101.     t))
  102.  
  103. (defun mark-word (count &optional pos)
  104.   "Marks COUNT words from POS."
  105.   (interactive "p")
  106.   (set-rect-blocks nil nil)
  107.   (mark-block (or pos (cursor-pos)) (forward-word count pos)))
  108.  
  109. (defun transpose-words (count)
  110.   "Move the word at (before) the cursor COUNT words forwards."
  111.   (interactive "p")
  112.   (transpose-items 'forward-word 'backward-word count))
  113.  
  114.  
  115. ;; Paragraphs
  116.  
  117. (defun forward-paragraph (&optional pos buf move)
  118.   "Returns the position of the start of the next paragraph. If MOVE
  119. is t then the cursor is set to this position."
  120.   (interactive "\n\nt")
  121.   (setq pos (or (find-next-regexp paragraph-regexp
  122.                   (next-char 1 (if pos
  123.                            (copy-pos pos) 
  124.                          (cursor-pos)))
  125.                   buf)
  126.         (buffer-end)))
  127.   (when move
  128.     (goto-char pos))
  129.   pos)
  130.  
  131. (defun backward-paragraph (&optional pos buf move)
  132.   "Returns the start of the previous paragraph. If MOVE is t the cursor is
  133. set to this position."
  134.   (interactive "\n\nt")
  135.   (setq pos (or (find-prev-regexp paragraph-regexp
  136.                   (prev-char 1 (if pos
  137.                            (copy-pos pos)
  138.                          (cursor-pos)))
  139.                   buf)
  140.         (buffer-start)))
  141.   (when move
  142.     (goto-char pos))
  143.   pos)
  144.  
  145. (defun mark-paragraph ()
  146.   "Set the block-marks to the current paragraph."
  147.   (interactive)
  148.   (let
  149.       ((par (forward-paragraph)))
  150.     (set-rect-blocks nil nil)
  151.     (mark-block (backward-paragraph par) par)))
  152.  
  153.  
  154. ;; Block handling
  155.  
  156. (defun copy-block (&aux rc)
  157.   "If a block is marked in the current window, return the text it contains and
  158. unmark the block."
  159.   (when (blockp)
  160.     (setq rc (funcall (if (rect-blocks-p) 'copy-rect 'copy-area)
  161.               (block-start) (block-end)))
  162.     (block-kill))
  163.   rc)
  164.  
  165. (defun cut-block (&aux rc)
  166.   "Similar to `copy-block' except the block is cut (copied then deleted) from
  167. the buffer."
  168.   (when (blockp)
  169.     (setq rc (funcall (if (rect-blocks-p) 'cut-rect 'cut-area)
  170.               (block-start) (block-end)))
  171.     (block-kill))
  172.   rc)
  173.  
  174. (defun delete-block ()
  175.   "Deletes the block marked in the current window (if one exists)."
  176.   (interactive)
  177.   (when (blockp)
  178.     (funcall (if (rect-blocks-p) 'delete-rect 'delete-area)
  179.          (block-start) (block-end))
  180.     (block-kill)))
  181.  
  182. (defun insert-block (&optional pos)
  183.   "If a block is marked in the current window, copy it to position POS, then
  184. unmark the block."
  185.   (interactive)
  186.   (when (blockp)
  187.     (if (rect-blocks-p)
  188.     (insert-rect (copy-rect (block-start) (block-end)) pos)
  189.       (insert (copy-area (block-start) (block-end)) pos))
  190.     (block-kill)))
  191.  
  192. (defun toggle-rect-blocks ()
  193.   "Toggles the state of the flag saying whether blocks in this window are
  194. marked sequentially (the default) or as rectangles."
  195.   (interactive)
  196.   (set-rect-blocks nil (not (rect-blocks-p))))
  197.  
  198. (defun kill-block ()
  199.   "Kills the block marked in this window."
  200.   (interactive)
  201.   (kill-string (cut-block)))
  202.  
  203. (defun copy-block-as-kill ()
  204.   "Kills the block marked in this window but doesn't actually delete it from
  205. the buffer."
  206.   (interactive)
  207.   (kill-string (copy-block)))
  208.  
  209. (defun mark-block (start end)
  210.   "Mark a block from START to END. This does an extra redraw if there's already
  211. a block marked to save lots of flicker."
  212.   (if (blockp)
  213.       (progn
  214.     (block-kill)
  215.     ;; Cunning hack -- the refresh algorithm(?) doesn't like the block
  216.     ;; killed then reset in one go, the whole screen is redraw :-( So
  217.     ;; do two refreshes...
  218.     (refresh-all))
  219.     (block-kill))
  220.   (block-start start)
  221.   (block-end end))
  222.  
  223. (defun mark-whole-buffer ()
  224.   "Mark a block containing the whole of the buffer."
  225.   (interactive)
  226.   (set-rect-blocks nil nil)
  227.   (mark-block (buffer-start) (buffer-end)))
  228.  
  229.  
  230. (defun upcase-area (start end &optional buffer)
  231.   "Makes all alpha characters in the specified region of text upper-case."
  232.   (interactive "-m\nM")
  233.   (translate-area start end upcase-table buffer))
  234.  
  235. (defun downcase-area (start end &optional buffer)
  236.   "Makes all alpha characters in the specified region of text lower-case."
  237.   (interactive "-m\nM")
  238.   (translate-area start end downcase-table buffer))
  239.  
  240. (defun upcase-word (count)
  241.   "Makes the next COUNT words from the cursor upper-case."
  242.   (interactive "p")
  243.   (let
  244.       ((pos (forward-word count)))
  245.     (upcase-area (cursor-pos) pos)
  246.     (goto-char pos)))
  247.  
  248. (defun capitalize-word ()
  249.   "The first character of this word (the one under the cursor) is made
  250. upper-case, the rest lower-case."
  251.   (interactive)
  252.   (unless (in-word-p)
  253.     (goto-char (find-next-regexp word-regexp)))
  254.   (translate-area (cursor-pos) (next-char) upcase-table)
  255.   (goto-next-char)
  256.   (when (in-word-p)
  257.     (downcase-word 1)))
  258.  
  259. (defun downcase-word (count)
  260.   "Makes the word under the cursor lower case."
  261.   (interactive "p")
  262.   (let
  263.       ((pos (forward-word count)))
  264.     (downcase-area (cursor-pos) pos)
  265.     (goto-char pos)))
  266.  
  267.  
  268. (defun mark-region ()
  269.   "Sets the block-marks to the area between the cursor position and the
  270. auto-mark"
  271.   (interactive)
  272.   (block-kill)
  273.   (when (eq (mark-file auto-mark) (current-buffer))
  274.     (let
  275.     ((curs (cursor-pos)))
  276.       (cond
  277.        ((> curs (mark-pos auto-mark))
  278.     (mark-block (mark-pos auto-mark) curs))
  279.        (t
  280.     (mark-block curs (mark-pos auto-mark)))))))
  281.  
  282.  
  283. ;; Killing
  284.  
  285. ;; Sometime I'll remove the dependancy on the *-clip functions, the killed
  286. ;; text is only accessed via these functions so it should be easy...
  287.  
  288. (defun kill-string (string)
  289.   "Adds STRING to the kill storage. If the last command also kill'ed something
  290. the string is appended to."
  291.   (write-clip 0 (if (eq last-command 'kill)
  292.             (concat (killed-string) string)
  293.           string))
  294.   ;; this command did some killing
  295.   (setq this-command 'kill)
  296.   string)
  297.  
  298. (defun killed-string (&optional depth)
  299.   "Returns the string in the kill-buffer at position DEPTH. Currently only one
  300. string is stored so DEPTH must be zero or not specified."
  301.   (if (or (null depth) (= depth 0))
  302.       (read-clip 0)
  303.     (error "No string at specified depth in kill storage" depth)))
  304.  
  305. (defun kill-area (start end)
  306.   "Kills a region of text in the current buffer from START to END."
  307.   (interactive "-m\nM")
  308.   (kill-string (cut-area start end)))
  309.  
  310. (defun copy-area-as-kill (start end)
  311.   "Copies a region of text in the current buffer (from START to END) to the
  312. kill storage."
  313.   (interactive "-m\nM")
  314.   (kill-string (copy-area start end)))
  315.  
  316. (defun kill-line (&optional arg)
  317.   "If the cursor is not at the end of the line kill the text from the cursor
  318. to the end of the line, else kill from the end of the line to the start of
  319. the next line."
  320.   (interactive "P")
  321.   (let
  322.       ((count (prefix-numeric-argument arg))
  323.        (start (cursor-pos))
  324.        end)
  325.     (cond
  326.      ((null arg)
  327.       (setq end (if (>= start (line-end))
  328.             (line-start (next-line))
  329.           (line-end))))
  330.      ((> count 0)
  331.       (setq end (line-start (next-line count))))
  332.      (t
  333.       (setq end start
  334.         start (line-start (next-line count)))))
  335.     (kill-area start end)))
  336.  
  337. (defun kill-whole-line (count)
  338.   "Kill the whole of the current line."
  339.   (interactive "p")
  340.   (kill-area (line-start) (line-start (next-line count))))
  341.  
  342. (defun backward-kill-line ()
  343.   "Kill from the cursor to the start of the line."
  344.   (interactive)
  345.   (kill-area (if (zerop (pos-col (cursor-pos)))
  346.          (prev-char)
  347.            (line-start))
  348.          (cursor-pos)))
  349.  
  350.  
  351. ;; Yank
  352.  
  353. (defun yank (&optional dont-yank-block)
  354.   "Inserts text before the cursor. If a block is marked in the current buffer
  355. and DONT-YANK-BLOCK is nil insert the text in the block. Else yank the last
  356. killed text."
  357.   (interactive "P")
  358.   (insert (if (and (null dont-yank-block) (blockp))
  359.           (copy-block)
  360.         (killed-string))))
  361.  
  362. (defun yank-rectangle (&optional dont-yank-block)
  363.   "Similar to `yank' except that the inserted text is treated as a rectangle."
  364.   (interactive "P")
  365.   (insert-rect (if (and (null dont-yank-block) (blockp))
  366.            (copy-block)
  367.          (killed-string))))
  368.  
  369. (defun yank-to-mouse ()
  370.   "Does a `(yank)' inserting at the current position of the mouse cursor. The
  371. cursor is left at the end of the inserted text."
  372.   (interactive)
  373.   (goto-char (mouse-pos))
  374.   (yank))
  375.  
  376.  
  377. (defun transpose-items (forward-item backward-item count)
  378.   "Transpose the areas defined by the functions FORWARD-ITEM and BACKWARD-
  379. ITEM (in the style of `forward-word', `backward-word' etc).
  380. COUNT is the number of items to drag the item at the cursor past.\n
  381. What actually happens is that the item before the cursor is dragged forward
  382. over the COUNT following items."
  383.   (let
  384.       (start1 start2 end1 end2)
  385.     (while (> count 0)
  386.       ;; go forwards
  387.       (setq start1 (funcall backward-item 1)
  388.         end1 (funcall forward-item 1 (copy-pos start1))
  389.         end2 (funcall forward-item 1 (copy-pos end1))
  390.         start2 (funcall backward-item 1 (copy-pos end2)))
  391.       (transpose-1)
  392.       (setq count (1- count)))
  393.     (while (< count 0)
  394.       ;; go backwards
  395.       (setq start1 (funcall backward-item 1)
  396.         end1 (funcall forward-item 1 (copy-pos start1))
  397.         start2 (funcall backward-item 1 (copy-pos start1))
  398.         end2 (funcall forward-item 1 (copy-pos start2)))
  399.       (transpose-1)
  400.       (setq count (1+ count)))))
  401.  
  402. (defun transpose-1 ()
  403.   (let
  404.       (text1 text2)
  405.     (if (< start2 start1)
  406.     (progn
  407.       (setq text1 (cut-area start1 end1)
  408.         text2 (copy-area start2 end2))
  409.       (insert text2 start1)
  410.       (delete-area start2 end2)
  411.       (goto-char (insert text1 start2)))
  412.       (setq text1 (copy-area start1 end1)
  413.         text2 (cut-area start2 end2))
  414.       (goto-char (insert text1 start2))
  415.       (delete-area start1 end1)
  416.       (insert text2 start1))))
  417.  
  418.  
  419. (defun abort-recursive-edit (&optional ret-val)
  420.   "Exits the innermost recursive edit with a value of VALUE (or nil)."
  421.   (interactive)
  422.   (throw 'exit ret-val))
  423.  
  424. (defun top-level ()
  425.   "Abort all recursive-edits."
  426.   (interactive)
  427.   (throw 'top-level nil))
  428.  
  429.  
  430. ;; Overwrite mode
  431.  
  432. (defvar overwrite-mode-p nil
  433.   "Non-nil when overwrite-mode is enabled.")
  434. (make-variable-buffer-local 'overwrite-mode-p)
  435.  
  436. (defun overwrite-mode ()
  437.   "Minor mode to toggle overwrite."
  438.   (interactive)
  439.   (if overwrite-mode-p
  440.       (progn
  441.     (setq overwrite-mode-p nil)
  442.     (remove-minor-mode 'overwrite-mode "Overwrite")
  443.     (remove-hook 'unbound-key-hook 'overwrite-insert))
  444.     (add-minor-mode 'overwrite-mode "Overwrite")
  445.     (setq overwrite-mode-p t)
  446.     (add-hook 'unbound-key-hook 'overwrite-insert)))
  447.  
  448. (defun overwrite-insert (&optional str)
  449.   (unless str
  450.     (setq str (current-event-string)))
  451.   (when str
  452.     (setq len (length str))
  453.     (delete-area (cursor-pos) (right-char len))
  454.     (insert str)))
  455.  
  456.  
  457. ;; Miscellaneous editing commands
  458.  
  459. (defun backspace-char (count)
  460.   "Delete COUNT characters preceding the cursor, if the cursor is past the
  461. end of the line simply move COUNT characters to the left."
  462.   (interactive "p")
  463.   (let
  464.       ((start (prev-char count)))
  465.     (if (> (cursor-pos) (line-end))
  466.     (if (> start (line-end))
  467.         (goto-char start)
  468.       (goto-line-end)
  469.       (delete-area start (cursor-pos)))
  470.       (delete-area start (cursor-pos)))))
  471.   
  472. (defun delete-char (count)
  473.   "Delete the character under the cursor."
  474.   (interactive "p")
  475.   (delete-area (cursor-pos) (next-char count)))
  476.  
  477. (defun tab-with-spaces ()
  478.   "Insert enough spaces before the cursor to move it to the next tab position."
  479.   (interactive)
  480.   (indent-to (pos-col (next-tab)) t))
  481.  
  482. (defun just-spaces (count)
  483.   "Ensure that there are only COUNT spaces around the cursor."
  484.   (interactive "p")
  485.   (when (member (get-char) '(?\  ?\t))
  486.     (let
  487.     ((pos (find-prev-regexp "[^\t ]|^")))
  488.       (when pos
  489.     (next-char 1 pos)
  490.     (when (and pos (looking-at "[\t ]+" pos))
  491.       (delete-area (match-start) (match-end))
  492.       (goto-char (match-start))))))
  493.   (unless (zerop count)
  494.     (insert (make-string count ?\ ))))
  495.  
  496. (defun no-spaces ()
  497.   "Delete all space and tab characters surrounding the cursor."
  498.   (interactive)
  499.   (just-spaces 0))
  500.  
  501. (defun open-line (count)
  502.   "Break the current line creating COUNT new lines, leaving the cursor in
  503. its original position."
  504.   (interactive "p")
  505.   (let
  506.       ((opos (cursor-pos)))
  507.     (insert (make-string count ?\n))
  508.     (goto-char opos)))
  509.  
  510. (defun transpose-chars (count)
  511.   "Move the character before the cursor COUNT characters forwards."
  512.   (interactive "p")
  513.   (transpose-items 'next-char 'prev-char count))
  514.